home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / glisp / glisp.000 / GLISP.UNIX.TAR / closunix / clos_lf7.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-04-03  |  9.1 KB  |  331 lines
  1. /*                 GRAPHIC LISP            */
  2. /*        Scritto nel 1991-94 da Zoia Andrea Michele     */
  3. /*        Via Pergola #1 Tirano (SO) Tel. 0342-704210    */
  4. /* file clos_lf7.c */
  5.  
  6. #include "clos.h"
  7.  
  8. #define PHASE_PARAM     0
  9. #define PHASE_OPTIONAL    1
  10. #define PHASE_REST      2
  11. #define PHASE_REST_1    3
  12. #define PHASE_REST_2    4
  13. #define PHASE_KEY       5
  14. #define PHASE_AUX       6
  15.  
  16. node    convert_to_parlist();
  17.  
  18.  
  19. void    lf_lambda LF_PARAMS
  20. {
  21.  /* controllare se non si usa mai EVAL */
  22.  /* allora tutte le variabili possono essere static */
  23.  int  phase;
  24.  node curr;
  25.  node parlist;
  26.  node l;
  27.  node prec;
  28.  node fun;
  29.  node anonimous;
  30.  node optional;
  31.  node rest;
  32.  node key;
  33.  node aux;
  34.  
  35.  node n_n;
  36.  node n_c;
  37.  
  38.  node u_type;
  39.  node prec_u_type;
  40.  node u_par;
  41.  node u_opt;
  42.  node u_rest;
  43.  node u_aux;
  44.  node u_key;
  45.  
  46.  /*(lambda(p1..pn &optional .... &rest name &key .... &aux .... )sx1 .. sxn)*/
  47.  /*  metasimbolo '....' significa [name | (name initialvalue)]* */
  48.  
  49.  
  50.  /* userfunc.params    =(p1 p2 .. pn)        */
  51.  /* userfunc.opt    =((opt1 . val1)..)    */
  52.  /* userfunc.rest    =restanme        */
  53.  /* userfunc.key    =((key1 . val1)..)    */
  54.  /* userfunc.aux    =((aux1 . val1)..)    */
  55.  /* userfunc.sexprs    =(sx1 .. sxn)        */
  56.  /* userfunc.env    =env            */
  57.  /* NB: i parametri normali possono anche essere: (parname classname) */
  58.  
  59.  
  60.  
  61.  phase=PHASE_PARAM;
  62.  prec=NIL;
  63.  
  64.  if(!IS_CONS(nin))
  65.         error(E_FEWARGS,ERR_TBLVL|ERR_MERROR|ERR_PNODE,&nin);
  66.  
  67.  /* si allocano questi nodi in modo da controllare  */
  68.  /* piu' velocemente il nome degli atomi */
  69.  /* perche' se 2 nodi hanno lo stesso nome */
  70.  /* hanno anche lo stesso handle */
  71.  optional=node_alloc("OPTIONAL");
  72.  rest=node_alloc("REST");
  73.  key=node_alloc("KEY");
  74.  aux=node_alloc("AUX");
  75.  
  76.  
  77.  u_type=u_par=u_opt=u_rest=u_key=u_aux=NIL;
  78.  
  79.  
  80.  l=parlist=list_dup(CONSLEFT(nin),DUP_LASTNIL); 
  81.         /* l=parameter-list (p1 p2 &optional....)    */
  82.         /* bisogna duplicarla perche' viene alterata */
  83.     /* si scarta l'eventuale ultimo elemento se la lista */
  84.     /* non finisce con NIL es: (2 3 . 4) --> (2 3) */
  85.  
  86.  /* si scandisce la lista l */
  87.  while(IS_CONS(l)){
  88.     curr=CONSLEFT(l);
  89.     switch(phase){
  90.           case PHASE_PARAM:
  91.             if(IS_NAME(curr) && HAS_NAME(curr)){
  92.               l=CONSRIGHT(prec=l); /* prossimo elemento */
  93.                                    /* e cosi' via fintanto */
  94.                                    /* che non si trova */
  95.                                    /* un nodo & */
  96.               if(u_type==NIL){
  97.                 u_type=prec_u_type=node_make();
  98.               }else{
  99.                 CONSRIGHT(prec_u_type)=node_make();
  100.                 prec_u_type=CONSRIGHT(prec_u_type);
  101.               }
  102.               TYPE(prec_u_type)|=NT_IS_CONS;
  103.               CONSLEFT(prec_u_type)=CONSRIGHT(prec_u_type)=NIL;
  104.               break;
  105.             }
  106.             if(IS_CONS(curr)){
  107.               /* si guarda se e' una lista (nome classe) */
  108.               n_n=CONSLEFT(curr);
  109.               if(IS_CONS(curr=CONSRIGHT(curr))){
  110.                 n_c=CONSLEFT(curr);
  111.                 if(IS_NAME(n_n)&&HAS_NAME(n_n)){
  112.                   if(IS_NAME(n_c)&&HAS_NAME(n_c)){
  113.                     if(HAS_CLASS(n_c)){
  114.                       CONSLEFT(l)=n_n;
  115.                       CONSRIGHT(curr)=NIL;
  116.                       if(u_type==NIL){
  117.                         u_type=prec_u_type=curr;
  118.                       }else{
  119.                         CONSRIGHT(prec_u_type)=curr;
  120.                         prec_u_type=curr;
  121.                       }
  122.               l=CONSRIGHT(prec=l);
  123.               break;    
  124.                     }
  125.                     error(E_UNBOUNDCLASS,ERR_TBLVL|ERR_PNODE|ERR_MERROR,&n_c);
  126.                   }
  127.                   error(E_BADARGS,ERR_TBLVL|ERR_PNODE|ERR_MERROR,&n_c);
  128.                 }
  129.                 error(E_BADARGS,ERR_TBLVL|ERR_PNODE|ERR_MERROR,&n_n);
  130.               }
  131.               error(E_BADLIST,ERR_TBLVL|ERR_PNODE|ERR_MERROR,&CONSLEFT(l));
  132.             }
  133.             if(IS_VALUE(curr)&&(GET_VTYPE(curr)==NT_ENAME)){
  134.                 if(prec!=NIL){
  135.                   CONSRIGHT(prec)=NIL; /* si spezza parlist  */
  136.                   u_par=parlist; /* e la si assegna a ufuncpar */
  137.                 }else{
  138.                   u_par=NIL;
  139.                 }
  140.                 if(ENAME(curr)!=optional)
  141.                    goto Optional_chk;
  142.                 parlist=l=CONSRIGHT(prec=l);
  143.                 phase=PHASE_OPTIONAL;
  144.                 break;
  145.             }
  146.             error(E_LAMBDASYNTAX,ERR_TBLVL|ERR_PNODE|ERR_MERROR,&CONSLEFT(nin));
  147.  
  148.           case PHASE_OPTIONAL:
  149.                 if(IS_VALUE(curr)&&(GET_VTYPE(curr)==NT_ENAME)){
  150.                     CONSRIGHT(prec)=NIL;
  151.                         /*l punta al prossimo cons */
  152.                         /* parlist contiene i parametri selezionati*/
  153.                         u_opt=convert_to_parlist(parlist);
  154.  
  155.                         Optional_chk:
  156.                         if(ENAME(curr)!=rest)
  157.                                 goto Rest_chk;
  158.                         parlist=l=CONSRIGHT(prec=l);
  159.                         phase=PHASE_REST_1;
  160.                         break;
  161.                 }
  162.                 l=CONSRIGHT(prec=l);
  163.                 break;
  164.  
  165.         case PHASE_REST_1:
  166.                     if(IS_NAME(curr)&&HAS_NAME(curr)){
  167.                         l=CONSRIGHT(prec=l);
  168.                         phase=PHASE_REST_2;
  169.                         break;
  170.                     }
  171.                     error(E_LAMBDASYNTAX,ERR_TBLVL|ERR_PNODE|ERR_MERROR,&CONSLEFT(nin));
  172.  
  173.         case PHASE_REST_2:
  174.             if(IS_VALUE(curr)&&(GET_VTYPE(curr)==NT_ENAME)){
  175.                                 u_rest=CONSLEFT(prec);
  176.                 Rest_chk:
  177.                 if(ENAME(curr)!=key)
  178.                     goto Key_chk;
  179.                 parlist=l=CONSRIGHT(prec=l);
  180.                 phase=PHASE_KEY;
  181.                 break;
  182.             }
  183.                     error(E_LAMBDASYNTAX,ERR_TBLVL|ERR_PNODE|ERR_MERROR,&CONSLEFT(nin));
  184.         case PHASE_KEY:
  185.             if(IS_VALUE(curr)&&(GET_VTYPE(curr)==NT_ENAME)){
  186.                 CONSRIGHT(prec)=NIL;
  187.                                 u_key=convert_to_parlist(parlist);
  188.                 Key_chk:
  189.                 if(ENAME(curr)!=aux)
  190.                                          error(E_LAMBDASYNTAX,ERR_TBLVL|ERR_PNODE|ERR_MERROR,&CONSLEFT(nin));
  191.                 parlist=l=CONSRIGHT(prec=l);
  192.                 phase=PHASE_AUX;
  193.                 break;
  194.             }
  195.             l=CONSRIGHT(prec=l);
  196.             break;
  197.         case PHASE_AUX:
  198.             if(IS_VALUE(curr)&&(GET_VTYPE(curr)==NT_ENAME))
  199.                                          error(E_LAMBDASYNTAX,ERR_TBLVL|ERR_PNODE|ERR_MERROR,&CONSLEFT(nin));
  200.             l=CONSRIGHT(l);
  201.             break;
  202.     }
  203.  }
  204.  switch(phase){
  205.     case PHASE_PARAM:
  206.                 u_par=parlist;
  207.         break;
  208.     case PHASE_OPTIONAL:
  209.                 u_opt=convert_to_parlist(parlist);
  210.         break;
  211.     case PHASE_REST_1:
  212.         break;
  213.     case PHASE_REST_2:
  214.                 u_rest=CONSLEFT(parlist);
  215.         break;
  216.     case PHASE_KEY:
  217.                 u_key=convert_to_parlist(parlist);
  218.         break;
  219.     case PHASE_AUX:
  220.                 u_aux=convert_to_parlist(parlist);
  221.         break;
  222.  }
  223.  
  224.  l=CONSRIGHT(nin); /* l=sexprs-list*/
  225.  
  226.  if(IS_CONS(l)){
  227.  
  228.         fun=node_make();
  229.         anonimous=node_make();
  230.  
  231.         FUNCTION(anonimous)=fun;
  232.         TYPE(fun)|=NT_IS_VALUE+NT_UFUNC;
  233.         TYPE(anonimous)|=NT_IS_NAME+NT_HAS_FUNCTION+NT_HAS_VALUE;
  234.     VALUE(anonimous)=anonimous;
  235.  
  236.         UFUNC_TYPE(fun)=u_type;
  237.     UFUNC_SEX(fun)=l;
  238.  
  239. /* lenv e' una lista di a-list */
  240. /* lenv-modifica */
  241.         UFUNC_ENV(fun)=lenv;
  242.         UFUNC_PAR(fun)=u_par;
  243.         UFUNC_OPT(fun)=u_opt;
  244.         UFUNC_AUX(fun)=u_aux;
  245.         UFUNC_REST(fun)=u_rest;
  246.     UFUNC_KEY(fun)=u_key;
  247.  
  248.     nout->type=P_VALUE;
  249.     nout->node=anonimous;
  250.     return;
  251.  }
  252.  error((l==NIL)?E_SLAMBDA:E_BADLIST,ERR_TBLVL|ERR_PNODE|ERR_MERROR,&nin);
  253. }
  254.  
  255.  
  256.  
  257.  
  258. node    convert_to_parlist( l)
  259. node l;
  260. {
  261.  /* prende in ingresso una lista ( A1 A2 ... An ) */
  262.  /* dove Ai e' [ Ni | (Ni Vi) ] {nome oppure lista con nome e valore} */
  263.  /* e genera una A-LIST  ( (N1 . V1) (N2 . V2) ... (Nn . Vn) ) */
  264.  /* dove Ni=NIL se Ai=Ni  Ni=Vi se Ai=(Ni Vi) */
  265.  /* se la lista d'ingresso ha qualche errore lo si segnala e si ritorna */
  266.  /* alla riga di comando */
  267.  
  268.  node alist;
  269.  node prev;
  270.  node n;
  271.  node lin;
  272.  node name;
  273.  node value;
  274.  
  275.  
  276.  alist=NIL;
  277.  lin=l;
  278.  prev=NIL;
  279.  
  280.  while(l!=NIL){
  281.         /* si scandisce l */
  282.  
  283.         if(IS_CONS(l)){
  284.                 n=CONSLEFT(l);
  285.                 if(IS_CONS(n)){/* caso n=(Ni Vi) */
  286.             value=CONSRIGHT(n);
  287.                         name=CONSLEFT(n);
  288.                         if(IS_CONS(value)){
  289.                                 if(CONSRIGHT(value)==NIL){
  290.                                         value=CONSLEFT(value);
  291.                                 }else{
  292.                                    error(E_LAMBDASYNTAX,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&lin);
  293.                                 }
  294.                         }else{
  295.                             error(E_LAMBDASYNTAX,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&lin);
  296.             }
  297.                 }else{ /* caso n=Ni */
  298.                         name=n;
  299.                         value=NIL;
  300.                 }
  301.                 /* si inserisce (name.value) in fondo ad alist */
  302.                 n=node_make();
  303.                 TYPE(n)|=NT_IS_CONS;
  304.                 CONSLEFT(n)=name;
  305.                 CONSRIGHT(n)=value;
  306.                 name=node_make();
  307.                 TYPE(name)|=NT_IS_CONS;
  308.                 CONSLEFT(name)=n;
  309.                 CONSRIGHT(name)=NIL;
  310.         if(alist==NIL){
  311.             alist=prev=name;
  312.         }else{
  313.             CONSRIGHT(prev)=name;
  314.             prev=name;
  315.         }
  316.         }else{
  317.              error(E_LAMBDASYNTAX,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&lin);
  318.         }
  319.         l=CONSRIGHT(l); /* prossimo elemento */
  320.  }
  321.  return alist;
  322. }
  323.  
  324.  
  325.  
  326.  
  327.  
  328.  
  329.  
  330.  
  331.